home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacMETH 3.2.1 / Sources / MacC3.3 / M2LA.MOD < prev    next >
Encoding:
Modula Implementation  |  1992-05-29  |  6.5 KB  |  230 lines  |  [TEXT/MEDT]
  1. IMPLEMENTATION MODULE M2LA; (* Hermann Seiler, 20.5.85 / 29.2.92 *)
  2.  
  3.   (*$R- to avoid range errors in the compiler! *)
  4.  
  5.   FROM SYSTEM IMPORT WORD, VAL;
  6.   FROM FileSystem IMPORT File, Response, Close, WriteWord;
  7.   FROM FileUtil IMPORT ExtLookup;
  8.   FROM M2DA IMPORT ObjPtr, StrPtr, KeyPtr, ObjClass;
  9.   FROM M2SA IMPORT Mark, IdBuf, Diff, Enter;
  10.  
  11.  
  12.   CONST
  13.  
  14.      CodeLength     = 27000;
  15.      ConstLength    = 5600;
  16.      CodeStartAdr   = 4; (* pointer to global data space at *)
  17.                          (* PC-relative address 0.          *)
  18.  
  19.  
  20.   VAR
  21.  
  22.      conx           : INTEGER;
  23.      codeoverflow   : BOOLEAN;
  24.      constoverflow  : BOOLEAN;
  25.      codeB          : ARRAY [ 0 .. CodeLength DIV 2 - 1 ] OF INTEGER;
  26.      constB         : ARRAY [ 0 .. ConstLength-1] OF CHAR;
  27.  
  28.  
  29.   PROCEDURE err(n : INTEGER);
  30.     (* local synonym for M2SM.Mark. *)
  31.   BEGIN
  32.     Mark(n);
  33.   END err;
  34.  
  35.   PROCEDURE PutWord(w : WORD);
  36.     (* put a 16-bit word into the code-buffer. *)
  37.   BEGIN
  38.     codeB[pc DIV 2] := VAL(INTEGER, w);
  39.     IF pc < CodeLength - 100 THEN
  40.       pc := pc + 2
  41.     ELSIF NOT codeoverflow THEN
  42.       codeoverflow := TRUE;
  43.       err(226);
  44.     END;
  45.   END PutWord;
  46.  
  47.   PROCEDURE PutLong(l : LONGINT);
  48.     (* put a 32-bit longword into the code-buffer. *)
  49.     VAR converter : RECORD
  50.                       CASE :BOOLEAN OF
  51.                         TRUE :  D   : LONGINT
  52.                       | FALSE:  H,L : INTEGER
  53.                       END
  54.                     END;
  55.   BEGIN converter.D := l;
  56.     PutWord(converter.H);
  57.     PutWord(converter.L);
  58.   END PutLong;
  59.  
  60.   PROCEDURE AllocString(s : INTEGER; VAR adr, length : INTEGER);
  61.     (* allocate a string-constant. *)
  62.     VAR L : INTEGER;
  63.   BEGIN
  64.     adr := conx;
  65.     L   := ORD(IdBuf[s]) - 1; INC(s); length := L;
  66.     (* for V3.0: include 0C in length of string *)
  67.     IF length # 1 THEN INC(length) END;
  68.     IF conx + L + 2 < ConstLength - 10 THEN
  69.       WHILE L > 0 DO
  70.         constB[conx] := IdBuf[s];
  71.         INC(conx); INC(s); DEC(L);
  72.       END;
  73.       constB[conx] := 0C; INC(conx);
  74.       (* assert word-alignment for strings : *)
  75.       IF ODD(conx) THEN constB[conx] := 0C; INC(conx) END;
  76.     ELSIF NOT constoverflow THEN
  77.       constoverflow := TRUE;
  78.       err(225);
  79.     END;
  80.   END AllocString;
  81.  
  82.   PROCEDURE AllocChar(ch : CHAR; VAR adr : INTEGER);
  83.     (* allocate a character-constant. *)
  84.   BEGIN
  85.     adr := conx;
  86.     IF conx + 2 < ConstLength - 10 THEN
  87.       (* Note : word-alignment is guaranteed by AllocString ! *)
  88.       constB[conx] := ch; INC(conx);
  89.       constB[conx] := 0C; INC(conx);
  90.     ELSIF NOT constoverflow THEN
  91.       constoverflow := TRUE;
  92.       err(225);
  93.     END;
  94.   END AllocChar;
  95.  
  96.   PROCEDURE AllocBounds(min, max, size : INTEGER; VAR adr : INTEGER);
  97.     (* allocate the bounds of a subrange or index. *)
  98.     VAR L : INTEGER;
  99.   BEGIN
  100.     adr := 0 (* signal NO bound-pair allocated! *)
  101.   END AllocBounds;
  102.  
  103.   PROCEDURE fixup(loc : INTEGER);
  104.     (* enter 16-bit displacement at loc. *)
  105.     VAR x : INTEGER;
  106.   BEGIN
  107.     x := pc - loc; (* forward distance in bytes *)
  108.     codeB[loc DIV 2] := x;
  109.   END fixup;
  110.  
  111.   PROCEDURE FixLink(L : INTEGER);
  112.     VAR L1 : INTEGER; i: INTEGER;
  113.   BEGIN i := 0;
  114.     WHILE (L > 0) & (L < CodeLength) & (i < 10000) DO
  115.       L1 := codeB[L DIV 2];
  116.       fixup(L);
  117.       L := L1; INC(i);
  118.     END;
  119.   END FixLink;
  120.  
  121.   PROCEDURE FixupWith(loc : INTEGER; disp : INTEGER);
  122.     (* enter 16-bit value disp at loc. *)
  123.   BEGIN
  124.     codeB[loc DIV 2] := disp;
  125.   END FixupWith;
  126.  
  127.   PROCEDURE FixLinkWith(L, val : INTEGER);
  128.     VAR L1 : INTEGER; i: INTEGER;
  129.   BEGIN i := 0;
  130.     WHILE (L > 0) & (L < CodeLength) & (i < 10000) DO
  131.       L1 := codeB[L DIV 2];
  132.       FixupWith(L, val - L); (* forward distance *)
  133.       L := L1; INC(i);
  134.     END;
  135.   END FixLinkWith;
  136.  
  137.   PROCEDURE MergedLinks(L0, L1 : INTEGER) : INTEGER;
  138.     (* merge chain of the 2 operands of AND and OR. *)
  139.     VAR L2, L3 : INTEGER; i: INTEGER;
  140.   BEGIN i := 0;
  141.     IF L0 # 0 THEN
  142.       L2 := L0;
  143.       LOOP
  144.         L3 := codeB[L2 DIV 2];
  145.         IF (L3 = 0) OR (i >= 10000) THEN EXIT END;
  146.         L2 := L3; INC(i);
  147.       END;
  148.       codeB[L2 DIV 2] := L1;
  149.       RETURN L0;
  150.     ELSE
  151.       RETURN L1
  152.     END;
  153.   END MergedLinks;
  154.  
  155.   PROCEDURE InitM2LM;
  156.   BEGIN
  157.     pc := CodeStartAdr;
  158.     codeB[0] := 4E71H; codeB[1] := 4E71H; (* NOP's for the Decoder *)
  159.     conx := 0; maxP := 0; maxM := 0;
  160.     codeoverflow := FALSE; constoverflow := FALSE;
  161.   END InitM2LM;
  162.  
  163.   PROCEDURE OutCodeFile(VAR name : ARRAY OF CHAR; stamp : KeyPtr;
  164.                         datasize : INTEGER; pno, progid : INTEGER;
  165.                         ModList : ObjPtr);
  166.     CONST HDR = 1; IMP = 2; COD = 3; DAT  = 4;
  167.     VAR   out: File; obj: ObjPtr; i, systemx: INTEGER; ok: BOOLEAN;
  168.  
  169.     PROCEDURE W(w: WORD); BEGIN WriteWord(out, w) END W;
  170.  
  171.     PROCEDURE WriteNameAndKey(id: INTEGER; stamp: KeyPtr);
  172.       VAR i, j, l, w: INTEGER; ch: CHAR;
  173.     BEGIN
  174.       l := ORD(IdBuf[id]); j := id;
  175.       FOR i := 1 TO 8 DO
  176.         IF l > 1 THEN INC(j); DEC(l); ch := IdBuf[j] ELSE ch := 0C END;
  177.         w := ORD(ch) * 256;
  178.         IF l > 1 THEN INC(j); DEC(l); ch := IdBuf[j] ELSE ch := 0C END;
  179.         W(w + ORD(ch));
  180.       END;
  181.       IF Diff(id, systemx) = 0 THEN
  182.         W(0); W(0); W(0);
  183.       ELSE
  184.         W(stamp^.k0); W(stamp^.k1); W(stamp^.k2);
  185.       END;
  186.     END WriteNameAndKey;
  187.  
  188.     PROCEDURE WriteEntries(mod: ObjPtr);
  189.       VAR obj: ObjPtr;
  190.     BEGIN obj := mod^.firstObj;
  191.       WHILE obj # NIL DO
  192.         IF (obj^.class = Proc) & obj^.pd^.exp THEN W(0); W(obj^.pd^.adr)
  193.         ELSIF (obj^.class = Module) THEN WriteEntries(obj)
  194.         END;
  195.         obj := obj^.next
  196.       END
  197.     END WriteEntries;
  198.  
  199.   BEGIN
  200.     ExtLookup(out, name, TRUE, ok);
  201.     IF NOT ok THEN
  202.       err(222); (* output file not opened *)
  203.       RETURN;
  204.     END;
  205.     systemx := Enter('System');
  206.     (* HeaderBlock *)
  207.     W(HDR); W(34); W(0); WriteNameAndKey(progid, stamp); W(pc);
  208.     W(datasize); W(conx); W(maxP); W(maxM);
  209.     (* ImportBlock *)
  210.     W(IMP); W((maxM-1) * 22); obj := ModList^.next^.next;
  211.     WHILE obj # NIL DO WriteNameAndKey(obj^.name, obj^.key); obj := obj^.next END;
  212.     WriteNameAndKey(systemx, stamp);
  213.     (* CodeBlock *)
  214.     W(COD); W(pc); FOR i := 0 TO pc DIV 2 - 1 DO W(codeB[i]) END;
  215.     (* DataBlock *)
  216.     W(DAT); W((maxP+maxM)*4 + conx); W(0); W(4); WriteEntries(ModList^.next);
  217.     FOR i := 1 TO maxM DO W(0); W(0) END;
  218.     i := 0;
  219.     WHILE i < conx DO
  220.       W(ORD(constB[i])*256 + ORD(constB[i+1]));
  221.       i := i + 2;
  222.     END;
  223.     Close(out);
  224.     IF out.res # done THEN
  225.       err(223); (* output incomplete *)
  226.     END;
  227.   END OutCodeFile;
  228.  
  229. END M2LA. (* Copyright Departement Informatik, ETH Zuerich, Switzerland, 1992 *)
  230.